;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; dataset.lsp
;;; Copyright (c) 1991-2000 by Forrest W. Young
;;; contains code for dataset and var macros and for var-proto object.
;;; Thanks to Luke Tierney for help with macros.
;;;
;;; This file defines the following functions:
;;;     DATASET  macro to create a data object     [(data) does same]
;;;     VAR      macro to create a variable object
;;;     $VARS    function to create variable objects from a data object
;;;
;;;DATASET
;;;(dataset)                    returns all data objects
;;;(dataset name)               returns all variables in data object name
;;;(dataset name var1 var2 <:type (type-symbols)>)
;;;(dataset name :variables varlist :data datalist  <keyword args>)
;;;                             creates data object from datalist and varlist
;;;(dataset name :program (form)) creates data object from form
;;;
;;;(vars)                       Returns all variables in current-data
;;;(vars name)                  Returns all variables in data object name
;;;(var)                        Returns the value of the current-variable
;;;(var  name)                  Returns the value of variable name in 
;;;                             the current-data, or, if no current-data,
;;;                             returns the most recently defined variable
;;;(var  name form              Binds variable to the result of form
;;;    <:type type-symbol>)     creating a variable of type type-symbol.
;;;                             The variable is added to the $free-vars list
;;;
;;;These functions define global variables used for referencing
;;;data objects and variable objects. There are two reference systems
;;;One uses names, the other uses file-directory style references:
;;;
;;;   NAMES         FILE/DIR    MEANING
;;;   $             $           current data
;;;   $vars         $.*         list of all variables in current data
;;;   $data         *.          list of all data objects
;;;   $all-vars                 list of all variables
;;;   $data-vars    *.*         list of all variables in all data objects
;;;   $free-vars     .*         list of all free variables
;;;   $name-vars    name.*      list of all variables in data object name
;;;   varname         $.varnam   name of a variable in current-data
;;;                 .varnam   name of a free-variable
;;;   dataname#n.varname        values of variable VARNAM in data-object DATANAME

#| 
   $                        $     current data
   name shortname                 data object "name" (the newly created data)
   $variables $vars         $.*   list of all variables in current data
   $data                    *.    list of all data objects
   $data-vars               *.*   list of all variables in all data objects
   $all-vars                      list of all variables
   $free-vars                .*   list of all free variables
   $name-vars            name.*   list of all variables in data object name
   $shortname-vars  shortname.*   list of all variables in data object name
   varname                        name of a variable in current-data
   dataname#n.varname             name of a variable in data-object dataname


Functions 
   $vars $variables $vars$ vars bins-$variables bind-variables 
are all aliased to methods 
   :$vars and :make-$variables 
of mv-data-object-proto to bind symbols corresponding to the names of variables in the current data object to the variables values, if not already bound. Returns variable symbols. Adds symbols to the $vars and $data-vars lists, and creates a list named $dsobname-vars which has all of the symbols on it.

|#

(defmacro dataset (&optional name &rest args)
"The DATASET macro creates a new data object. It can also report the names of data objects. It can be used in the several \"short-form\" ways, and in the complete \"long-form\" way. The short-form syntax is discussed here, with the long-form following.
_________________

SHORT-FORM SYNTAX:
_________________

1) To see a list of all data objects, type:
   (DATASET)

2) To see the object identification of data object NAME, type:
   (DATASET NAME)

3) To create a new data object from variables in other data objects or from variables previously defined by the VAR function or by ViVa statements, type:
   (DATASET NAME VAR1 VAR2 ...)
where NAME is the name of the new data object being created, and VAR1 VAR2, etc, are the names of variables created by VAR statements. Each name must be a symbol. When the variables are not all numeric, you must include the :TYPES keyword, followed by the types:
   (DATASET NAME VAR1 VAR2 :TYPES (NUMERIC CATEGORY))
Each type must be a symbol. The variables must all have the same number of observations. The most recent variable is used when there are duplicate variable names. Long variable names may be used. 
   Type $VARS for the list of variable names in the currently active data object, $DATA-VARS for the names of all variables in all data objects, or $FREE-VARS for all variables free from being in data objects (i.e., created by the VAR functions), or $ALL-VARS for all variables.

4) To create a new data object from variables in a specific data object, type:
   (DATASET NAME VAR1 VAR2 ... :USE IN-NAME)
where NAME and VAR1 VAR2, etc, are as above and IN-NAME is the name of an existing data-object. Type $IN-NAME-VARS for the list of variable names.

5) To create a new data object from a program contained within the DATA-OBJECT statement, type:
   (DATASET NAME FORM)
where NAME is the name of the new data object, and FORM is a Lisp form. 

_________________

LONG-FORM SYNTAX:
_________________

The complete \"long-form\" of the DATASET function creates a new data object from information contained within the DATASET statement. The minimum required syntax is:
   (DATASET NAME :VARIABLES (VAR1 VAR2 ... ) :DATA (DATALIST) )
The required arguments are discussed next, with optional long-form arguments following:

REQUIRED ARGUMENTS: NAME &KEY :DATA :VARIABLES

  NAME must be a string or a symbol. This is the name of the newly defined data object.
  
  :VARIABLES must be followed by a list of strings symbols defining variable names (and, indirectly, the number of variables). 

  :DATA must be followed by a list of numbers, strings or symbols (symbols are converted to uppercase strings). The number of data elements must conform to the information in other arguments.

GENERAL OPTIONAL ARGUMENTS: &KEY :TYPES :LABELS :FREQ :ABOUT 

  :TYPES must be followed by a list of strings \"numeric\", \"ordinal\" or \"category\" (case ignored), or symbols (same as strings, but no quotes) specifying whether the variables are numeric, ordinal or categorical (all numeric by default). 

  :LABELS must be followed by a list of strings specifying observation names (\"Obs1\", \"Obs2\", etc., by default). 

  :FREQ must be followed by T to specify that the values of the numeric variables are frequencies. 

  :ABOUT is followed by an optional string of information about the data.

Given these arguments above you can specify:
1) MULTIVARIATE data are data which are not one of the other data types given below. These data include univariate (one numeric or ordinal variable) and bivariate (two numeric or ordinal variables) data.
2) CATEGORY data have one or more CATEGORY variables and no NUMERIC or ORDINAL variables. The N category variables define an n-way classification.
3) CLASSIFICATION data have one NUMERIC variable and one or more CATEGORY variables. The N category variables define an n-way classification. The numeric variable specifies an observation for a given classification. 
4) FREQUENCY CLASSIFICATION data are classification data whose numeric variable specifies frequencies as indicated by using FREQ. The N category variables define an n-way classification, with the numeric variable specifying the co-occurance frequency of a specific combination of categories.

Using the arguments specified below, you can also create
5) FREQUENCY TABLE data are data whose observations and variables are used to form the rows and columns of a two-way table. That is, the data are a two-way cross tabulation of the co-occurance frequency formed from the observations and variables. The data elements must be frequencies.
6) MATRIX data are data whose observations and variables refer to the same things. These things are used to form a square, usually symmetric matrix with the same number of rows and columns, the rows and columns identifying the same things. The values might be correlations, covariances, distances, etc. Optionally, there can be more than one matrix in a given data object. All matrices must have rows and columns identifying the same things.

OPTIONAL ARGUMENTS FOR FREQUENCY TABLE DATA: 
&KEY :ROW-LABEL, :COLUMN-LABEL

The variables must be NUMERIC and :FREQ T must be specified. In addition, :ROW-LABEL and :COLUMN-LABEL must be used. Each must be followed by a string. The string is used to label the rows or columns of the table. 

OPTIONAL ARGUMENTS FOR MATRIX DATA
ARGUMENTS: &KEY :MATRICES :SHAPES 
:MATRICES, used only for matrix data, must be followed by a list of strings specifying matrix names (and, indirectly, the number of matrices). :SHAPES, optional for matrix data only, must be a list of strings \"symmetric\" or \"asymmetric\" (case ignored), specifying the shape of each matrix (all are symmetric by default)."

  (cond
    ((not name)
     (format t "~a~%" $data))
    ((not args)
     (let ((stok)
           (st "; unknown data object")
           )
       (if (ignore-errors (setf stok (eval name)))
           stok (format nil "~a~%" st)))
     )
    (t
     (let* ((first (first args))
            (variable? (and (symbolp (first args)) (listp (eval (first args)))))
            (program? (list-of-equal-length-lists-p first))
            (keywords? (position 't (mapcar #'keywordp args)))
            (data? (and (not program?) (not variable?)))
            (program (if program? first nil))
            (nargs (length args))
            (usesym (gensym))
            (namesym (gensym))
            (nameeval)
            (keywords)
            )

       (when variable? 
             (when keywords? 
                   (setf keywords (select args (iseq keywords? (1- nargs))))
                   (setf args (select args (iseq keywords?))))
             (setf datacolumns  (map-elements #'eval args))
             (setf datalist (combine (row-list (apply #'bind-columns datacolumns))))
             (setf keywords (append keywords (list ':variables args ':data datalist))))
       (when program?
             (setf keywords (combine (list ':program program) keywords)))
       (when data?
             (setf keywords 
                   (mapcar #'(lambda (i)
                               (if (= (mod i 2) 0)
                                   (eval (select args i))
                                   (select args i)))
                           (iseq nargs))))
       
       (when (setf loc-use (position ':use keywords))
             (setf (select keywords (1+ loc-use)) (eval (select keywords (1+ loc-use)))))
(when *verbose* (print (list "IN FILE DATASET.LSP" keywords)))
       (cond 
         ((stringp name)
(when *verbose* (print `(apply #'the-real-data-function ,name ',keywords)))
          `(apply #'the-real-data-function ,name ',keywords))
         ((symbolp name)
          `(let ((,namesym (string ',name)))
(when *verbose* (print `(apply #'the-real-data-function ,namesym ',keywords)))
             (apply #'the-real-data-function ,namesym ',keywords)))
         (t
          (setf nameeval (eval name))
          `(let ((,namesym (string ',nameeval)))
(when *verbose* (print `(apply #'the-real-data-function ,name ',keywords)))
             (apply #'the-real-data-function ,namesym ',keywords))))
       ))))
  


(defmacro var (&rest args)
"VAR 
Purpose: Macro to create a ViSta variable object. When creating, name of new variable object is added to the $free-vars and $all-vars lists.
Syntax: (var variable &optional form &key (type numeric))
Usage: var can be used in three ways:
1: (var variable) to report the value of variable
   Example: (var midterm-correct)
2: (var variable form) to bind variable to the result of form
   Example: (var final-points (* 2 (list 78 45 67 93 89)))
3: (var variable form :type typesymbol) like 2, but non-numeric variable
   Example: (var grades '(b d c a a- ) :type category)
VARIABLE is not evaluated and must be a symbol.  
  When FORM is specified, it is evaluated, returned, and bound to VARIABLE, with VARIABLE being appended to $ALL-VARS, the list of all ViSta variables and $FREE-VARS, the list of all ViSta variables that are not in a dataobject. Also, when FORM is specified a variable $VARIABLE is created and bound to the object-id of VARIABLE. 
  When FORM is not specified, returns the value of VARIABLE if it is on the $ALL-VARS list. Produces an error if not. 
  VARIABLE will be NUMERIC unless TYPE is the symbol ORDINAL, CATEGORY, FREQ or LABEL. TYPE cannot be specified unless FORM is specified. If VARIABLE is already bound and the global variable *ASK-ON-REDEFINE* is not nil then you are asked if you want to redefine the variable."

  (let* ((nargs (length args)) (name) (value) (key) (type))
    (when (= nargs 0) (error "too few arguments"))
    (when (> nargs 0) (setf name (first args)))
    (when (= nargs 1) 
          (unless (member name $all-vars)
                  (error (format nil "; ~a is not a ViSta variable object." member))
                  (setf value (eval name))))
    (when (> nargs 1)
          (setf value (eval (second args)))
          (when (and *ask-on-redefine*
                     (member name (combine $data-vars $desk-vars $viva-vars)))
                (unless (yes-or-no-dialog 
                        (format nil "Variable ~a already defined.~%Redefine OK?"
                                name))
                 (error "variable cannot be redefined")))
          (setf object (send var-proto :new name value type))
          (set (intern (string-upcase name)) (send object :value))
          (setf $free-vars (append $free-vars (list name)))
          (setf $all-vars  (append $all-vars  (list name)))
          (set (intern (string-upcase (strcat "$" (string name)))) object)
          (when (not (equal name (send object :viva-name)))
                (set (intern (string-upcase (send object :viva-name)))
                     (send object :value))
                (setf $all-vars 
                      (append $all-vars (list (send object :viva-name))))
                (setf $free-vars (append $free-vars (list (send object :viva-name)))))
          )
    (when (> (length args) 2)
          (unless (equal (third args) ':type) 
                  (error "unknown keyword")))
    (when (> (length args) 3)
          (setf type (fourth args))
          (unless (member type (list 'category 'numeric 'ordinal 'freq 'label))
                  (error "unknown variable type")))
    (when (> (length args) 4)
          (error "too many arguments"))
    name
    ))

(defproto var-proto '(name value type viva-name) '() )

(defmeth var-proto :isnew (name value type)
  (send self :name name)
  (send self :value value)
  (send self :type (if type type "numeric"))
  (send self :viva-name (send self :dash-to-underscore name))
  self)

(defmeth var-proto :name (&optional (string nil set))
"Args: (&optional string)
 Sets or retrieves the name of the variable."
  (if set (setf (slot-value 'name) string))
  (slot-value 'name))


(defmeth var-proto :viva-name (&optional (string nil set))
"Args: (&optional string)
 Sets or retrieves the viva-name of the variable (with dashes changed to underscores)."
  (if set (setf (slot-value 'viva-name) string))
  (slot-value 'viva-name))

(defmeth var-proto :value (&optional (form nil set))
"Args: (&optional form)
 Sets or retrieves the value of the variable."
  (if set (setf (slot-value 'value) form))
  (slot-value 'value))

(defmeth var-proto :type (&optional (symbol nil set))
"Args: (&optional string)
 Sets or retrieves the type of the variable."
  (if set (setf (slot-value 'type) symbol))
  (slot-value 'type))

(defmeth var-proto :vistatype (&optional (str nil set))
"Message args: (&optional logical)
 Sets or retrieves the object id string."
  (when (not (send self :has-slot 'vistatype))(send self :add-slot 'vistatype))
  (when (not (slot-value 'vistatype)) (slot-value 'vistatype (send self :make-vistatype)))
  (if set (setf (slot-value 'vistatype) str))
  (slot-value 'vistatype))

(defmeth var-proto :make-vistatype ()
  (format nil "~aData[~a]"
          (if (equal "numeric" (string-downcase (send self :type)))
              "NumVar" "CatVar")
          (length (send self :value))))

(defmeth var-proto :make-object-id (&key (subject nil)) 
  (format nil "#<Object: ~a   ;#<StatObj: ~a>"
          (send self :name)
          (send self :make-vistatype)))


(defmeth var-proto :print (&optional (stream *standard-output*))
"Method args: (&optional (stream *standard-output*))
Default object printing method."
  (format stream "~a   ;#<StatObjType: ~a>" 
          (send self :name) (send self :vistatype)))


(defmeth var-proto :dash-to-underscore (symbol-or-string)
"takes symbol or string as argument, changes all dashes to underscores and return symbol"
  (dash-to-underscore symbol-or-string))

(defun dash-to-underscore (symbol-or-string)
  (let* ((string (if (symbolp symbol-or-string) 
                     (format nil "~a" symbol-or-string)
                     symbol-or-string))
         (position (search-string "-" string))
         (new-string string))
    (cond 
      (position (setf new-string (substitute-string "_" string position))
                (when (equal "_" (subseq new-string (1- (length new-string))))
                      (setf new-string 
                            (subseq new-string 0 (1- (length new-string)))))
                (dash-to-underscore new-string))
      (t (intern (string-upcase string))))))


(defun dash-to-underscore (symbol-or-string)
  (let* ((string (cond 
                   ((symbolp symbol-or-string) 
                    (format nil "~a" symbol-or-string))
                   ((stringp symbol-or-string)
                    symbol-or-string)
                   (t nil)))
         (position (if string (search "-" string) nil))
         (new-string string))
    (cond 
      ((not string) symbol-or-string)
      (position (setf new-string (substitute-string "_" string position))
                (when (equal "_" (subseq new-string (1- (length new-string))))
                      (setf new-string 
                            (subseq new-string 0 (1- (length new-string))))
                      )
                (if (> (length new-string) 0)
                    (underscore-to-dash new-string)
                    (intern (string-upcase "_"))))
      (t (intern (string-upcase string))))
    new-string))

     
